home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Travers' lisp contrib.sea / Travers' lisp contrib / mt-utils.lisp < prev    next >
Encoding:
Text File  |  1992-01-23  |  12.3 KB  |  417 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: COMMON-LISP-USER; Base: 10 -*-
  2. ;;; MT's utility library
  3. ;;; Copyright Mike Travers 1987 et(c)etera.
  4. ;;; not yet completely converted to MCL
  5.  
  6. ;;; Some things here stolen from others.
  7.  
  8. ;;; Small syntactical aids.
  9.  
  10. (in-package :cl-user)
  11.  
  12. (defmacro non-nil (var)
  13.   `(and (boundp ',var)
  14.     ,var))
  15.  
  16. (declaim (ignore ignore))               ; So sue me
  17.  
  18. ;;; Lifted from PCL.  Ensure that a macro variable is only expanded once.
  19. #-GENERA
  20. (defmacro once-only (vars &body body)
  21.   (let ((gensym-var (gensym))
  22.         (run-time-vars (gensym))
  23.         (run-time-vals (gensym))
  24.         (expand-time-val-forms ()))
  25.     (dolist (var vars)
  26.       (push `(if (or (symbolp ,var)
  27.                      (numberp ,var)
  28.                      (and (listp ,var)
  29.               (member (car ,var) '(quote function))))
  30.                  ,var
  31.                  (let ((,gensym-var (gensym)))
  32.                    (push ,gensym-var ,run-time-vars)
  33.                    (push ,var ,run-time-vals)
  34.                    ,gensym-var))
  35.             expand-time-val-forms))    
  36.     `(let* (,run-time-vars
  37.             ,run-time-vals
  38.             (wrapped-body
  39.               ((lambda ,vars . ,body) . ,(reverse expand-time-val-forms))))
  40.        `((lambda ,(nreverse ,run-time-vars)  ,wrapped-body)
  41.          . ,(nreverse ,run-time-vals)))))
  42.  
  43. (defmacro return-if (val)
  44.   (once-only (val)
  45.     `(if ,val (return ,val))))
  46.  
  47. (defmacro return-from-if (block val)
  48.   (once-only (val)
  49.     `(if ,val (return-from ,block ,val))))
  50.  
  51. #-CCL
  52. (defmacro neq (a b)
  53.   `(not (eq ,a ,b)))
  54.  
  55. ;;; Iteration and Mapping
  56.  
  57. (defmacro dosequence ((var sequence &optional result) &body body)
  58.   `(dolist (,var (coerce ,sequence 'list) ,result) ,@body))
  59.  
  60. ;;; Sequence functions (but only working on lists for now)
  61. ;;; +++ flush return-max, return multiple-values 
  62. (defun extreme (list test &key (key #'identity) (return-max nil))
  63.   (and list
  64.        (let* ((best (car list))
  65.               (max (funcall key best)))
  66.          (dolist (other (cdr list) (if return-max max best))
  67.            (let ((score (funcall key other)))
  68.          (when (funcall test score max)
  69.                (setq best other max score)))))))
  70.  
  71. (defun extremes (list test &key (key #'identity))
  72.   (if list
  73.     (let* ((best (list (car list)))
  74.            (max (funcall key (car best))))
  75.       (dolist (other (cdr list) (values best max))
  76.         (let ((score (funcall key other)))
  77.           (if (funcall test score max)
  78.             (setq best (list other) max score)
  79.             (if (funcall test max score)
  80.               nil
  81.               (push other best))))))
  82.     (values nil most-negative-fixnum)))
  83.  
  84. (defun maximize (list &key (key #'identity) (return-max nil))
  85.   (declare (inline extreme))            ; not that this does anything
  86.   (extreme list #'> :key key :return-max return-max))
  87.  
  88. (defun minimize (list &key (key #'identity) (return-max nil))
  89.   (declare (inline extreme))            ; not that this does anything
  90.   (extreme list #'< :key key :return-max return-max))
  91.  
  92. (defun maximums (list &key (key #'identity))
  93.   (declare (inline extremes))            ; not that this does anything
  94.   (extremes list #'> :key key))
  95.  
  96. (defun minimums (list &key (key #'identity))
  97.   (declare (inline extremes))            ; not that this does anything
  98.   (extremes list #'< :key key))
  99.  
  100. (defun random-element (list)
  101.   (and list
  102.        (nth (random (length list)) list)))
  103.  
  104. (defmacro do-for-array-elements (array vars &body body)
  105.   `(let ((array-dimensions (array-dimensions ,array)))
  106.      (do-for-array-elements-1 ,array ,vars 0 ,@body)))
  107.  
  108. (defmacro do-for-array-elements-1 (array vars dim &body body)
  109.   (if vars
  110.       `(dotimes (,(car vars) (nth ,dim array-dimensions))
  111.      (do-for-array-elements-1 ,array ,(cdr vars) ,(1+ dim)
  112.        ,@body))
  113.       `(progn ,@body)))
  114. ;;; do-collect
  115. ;;; generalized good iterator.
  116.  
  117. (defun circular-list (&rest elements)
  118.   (rplacd (last elements) elements))
  119.  
  120. (defun string-replace-char (string char0 char1 &key (start 0) (end nil))
  121.   (do ((from start)
  122.        (new-string (concatenate 'string string)))
  123.       ((null from) new-string)
  124.     (setq from (position char0 string :start (1+ from) :end end))
  125.     (when from
  126.       (setf (char new-string from) char1))))
  127.  
  128. ;;; These stolen from KWH
  129. (defun collect (fcn list)
  130.   "Applies FCN to each element of LIST returning all the non-nil values as a list."
  131.   (let* ((head (list 'HEAD)) 
  132.          (tail head))
  133.     (dolist (elt list (cdr head))
  134.       (let ((value (funcall fcn elt)))
  135.     (when value
  136.       (push value (cdr tail))
  137.       (setf tail (cdr tail)))))))
  138.  
  139. (defun mapappend (fcn list)
  140.   "Applies FCN to every element of LIST, appending the results together.
  141. Order is maintained as one might expect."
  142.   (let* ((head (list '())) (tail head))
  143.     (dolist (elt list (cdr head))
  144.       (dolist (result-elt (funcall fcn elt))
  145.     (setf (cdr tail) (list result-elt))
  146.     (setf tail (cdr tail))))))
  147.  
  148. (defun mapunion (fcn list)
  149.   "Applies FCN to every element of LIST, unioning the results together.
  150. Except for removal of EQL occurences, order is maintained as one might expect."
  151.   (let* ((head (list '())) (tail head))
  152.     (dolist (elt list (cdr head))
  153.       (dolist (result-elt (funcall fcn elt))
  154.     (unless (member result-elt head)
  155.       (setf (cdr tail) (list result-elt))
  156.       (setf tail (cdr tail)))))))
  157.  
  158. (defun mapcross (fcn list1 list2)
  159.   "Applies FCN to every combination of elements from LIST1 and LIST2,
  160. returning the list of results.  Order is maintained as one might expect."
  161.   (let* ((head (list '())) (tail head))
  162.     (dolist (e1 list1 (cdr head))
  163.       (dolist (e2 list2)
  164.     (push (funcall fcn e1 e2) (cdr tail))
  165.     (setf tail (cdr tail))))))
  166.  
  167. (defun split-list (predicate list)
  168.   "Returns two lists extracted from list based on PREDICATE."
  169.   (let ((wheat '()) (chaff '()))
  170.     (dolist (elt list (values wheat chaff))
  171.       (if (funcall predicate elt)
  172.       (push elt wheat) (push elt chaff)))))
  173.  
  174. (defun filter (predicate list &aux wheat)
  175.   "Return only the elements of list meeting PREDICATE"
  176.   (dolist (elt list wheat)
  177.     (when (funcall predicate elt)
  178.       (push elt wheat))))
  179.  
  180.  
  181. ;;; String Parse Utility
  182.  
  183. ;;; Generalized variables, binding, etc.
  184.  
  185. (defmacro deletef (thing place &rest delete-args)
  186.   (once-only (place)
  187.     `(setf ,place (delete ,thing ,place ,@delete-args))))
  188.  
  189. ;;; mv-let*: lets the car of a let binding form be a list
  190. ;;; elements of which get bound to multiple values.
  191.  
  192. (defmacro mv-let* (forms &body body)
  193.   (cond ((null forms)
  194.      `(progn ,@body))
  195.     ((or (symbolp (car forms))
  196.          (symbolp (caar forms)))
  197.  
  198.      `(let (,(car forms))
  199.         (mv-let* ,(cdr forms)
  200.           ,@body)))
  201.     (t
  202.      `(multiple-value-bind ,(caar forms) ,(cadar forms)
  203.         (mv-let* ,(cdr forms)
  204.           ,@body)))))
  205.  
  206. #+GENERA
  207. (defmacro bind-keyword-vars ((arglist keyvars) &body body)
  208.   `(let ,keyvars
  209.      (zl:keyword-extract ,arglist ,(gensym) ,keyvars nil
  210.        ,@body)))
  211.  
  212. ;;; destructuring-let
  213.  
  214. ;;; Function hacking
  215.  
  216. ; Define a function that caches its values.  The function should be a function
  217. ; in the mathematical sense (a mapping with no state).  It can't take a rest or
  218. ; optional args.
  219. (defmacro def-cached-function (name arglist &body body)
  220.   (let ((ht (make-hash-table :test #'equal)))
  221.     `(defun ,name (&rest args)
  222.        (multiple-value-bind (val found)
  223.        (gethash args ,ht)
  224.      (if found 
  225.          val
  226.          (setf (gethash (copy-list args) ,ht)
  227.            (destructuring-bind ,arglist args
  228.              ,@body)))))))
  229.     
  230. (defmacro test-defun (name args &body body)
  231.   `(progn
  232.      (defun ,name ,args ,@body)
  233.      (compile ',name)
  234.      (disassemble ',name)))
  235.  
  236. #+GENERA
  237. (defun allow-redefinition (fspec &optional (type 'defun))
  238.   (when (boundp 'si:fdefine-file-definitions)
  239.     (si:allow-redefinition fspec type)))
  240.  
  241. (defmacro defsubst (name args &body body)
  242.   `(progn
  243.      (defun ,name ,args
  244.        ,@body)
  245.      (declaim (inline ,name))))
  246.           
  247. #+MCL (pushnew "subst" 
  248.                (cdr (assoc 'function ccl::*define-type-alist*)))
  249.  
  250.  
  251. ;;; Numerics
  252.  
  253. (defmacro ^ (x y)
  254.  `(expt ,x ,y))
  255.  
  256. (defsubst sign (num)
  257.   (cond ((plusp num) 1)
  258.     ((minusp num) -1)
  259.     (t 0)))
  260.  
  261. (defsubst abs-max (max num)
  262.   (if (<= (abs num) max)
  263.       num
  264.       (* max (sign num))))
  265.  
  266. #+GENERA
  267. (defmacro now () '(time:time))
  268. #+CCL
  269. (defmacro now () '(get-internal-real-time))     ; no idea if this is best, but it's something
  270.  
  271. (defun arand (center range)
  272.   (+ center (random (* 2.0 range)) (- range)))
  273.  
  274. (eval-when (load compile eval)
  275.   (defconstant single-pi (coerce pi 'single-float)))    ;Avoid introducing double-floats
  276. (defconstant degrees-to-radians (/ (* 2 single-pi) 360))
  277. (defconstant radians-to-degrees (/ degrees-to-radians))
  278. (defmacro d2r (deg)
  279.   `(* degrees-to-radians ,deg))
  280. (defmacro d2ri (deg)
  281.   (* degrees-to-radians deg))
  282. (defmacro r2d (rad)
  283.   `(* radians-to-degrees ,rad))
  284.  
  285. ;;; Fast integer arithmetic.  More or less stolen from Boxer
  286.  
  287. (defmacro int (x) `(the fixnum ,x))
  288. (defmacro def-arith-op (int-name reg-name)
  289.   `(defmacro ,int-name (&rest args)
  290. ;     (declare (arglist ,(arglist reg-name)))
  291.      `(the fixnum (,',reg-name ,@(mapcar #'(lambda (arg) `(the fixnum ,arg)) args)))))
  292.  
  293. (def-arith-op +& +)                     ; Only addition-type ops actually get any boost in MCL2.0
  294. (def-arith-op -& -)
  295. (def-arith-op incf& incf)
  296. (def-arith-op decf& decf)
  297. (def-arith-op 1+& 1+)
  298. (def-arith-op 1-& 1-)
  299. #|
  300. (def-arith-op *& *)
  301. (def-arith-op /& /)
  302. (def-arith-op max& max)
  303. (def-arith-op min& min)
  304. |#
  305.  
  306.  
  307. ;;; Safety-last versions of these (note: in MCL2.0, svref& compiles inline, aref& does not)
  308. (defmacro svref& (vector index)
  309.   `(let ()
  310.      (declare (optimize (speed 3) (safety 0)))
  311.      (svref ,vector (the fixnum ,index))))
  312.  
  313. (defmacro aref& (array &rest indicies)
  314.   `(let ()
  315.      (declare (optimize (speed 3) (safety 0)))
  316.      (aref ,array ,@(mapcar #'(lambda (index) `(the fixnum ,index)) indicies))))
  317.  
  318. (defun integers (from to)
  319.   (if (equal from to) (list from)
  320.       (cons from (integers (+ from (sign (- to from))) to))))
  321.  
  322. (defun log2 (x)
  323.   (/ (log x) (log 2)))
  324.  
  325. (defun number-of-bits (n)   ;;; smallest k st 2**kn
  326.   (ceiling (log2 n)))
  327.  
  328. (defun average (list)
  329.   (if (null list) 0
  330.       (/ (apply #'+ list) (length list))))
  331.  
  332. (defun std-dev (list &aux (average (average list)))
  333.   (sqrt (/ (apply #'+ 
  334.                    (mapcar #'(lambda (x) (expt (- x average) 2)) 
  335.                            list))
  336.             (length list))))
  337.  
  338. (defun geo-mean (list)
  339.   (nth-root (apply #'* list) (length list)))
  340.  
  341. (defun nth-root (x n)
  342.   (if (> x 0) (exp (/ (log x) n))
  343.       (error "In NTH-ROOT, X=~S is not positive." x)))
  344.  
  345. (defvar pi/2 (/ single-pi 2.0))
  346. (defvar pi/4 (/ single-pi 4.0))
  347. (defvar 2pi (* single-pi 2))
  348.  
  349. (defun symbol-conc (&rest parts)
  350.   (intern (apply #'concatenate 'string (mapcar 'string parts))))
  351.  
  352. ;;; stolen from CLIM
  353. (defun format-time (time &optional (stream *standard-output*))
  354.   (let (second minute hour date month year day daylight-savings-p time-zone)
  355.     (multiple-value-setq
  356.     (second minute hour date month year day daylight-savings-p time-zone)
  357.       (get-decoded-time))
  358.     (multiple-value-setq
  359.     (second minute hour date month year day daylight-savings-p time-zone)
  360.       (if (<= 5 time-zone 8)        ;US-centric, to be sure
  361.       (decode-universal-time time)
  362.       (decode-universal-time time 0)))
  363.     (princ (nth day
  364.         '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
  365.        stream)
  366.     (princ " " stream)
  367.     (princ (nth (1- month)
  368.         '("Jan" "Feb" "Mar" "Apr" "May" "June"
  369.           "July" "Aug" "Sept" "Oct" "Nov" "Dec"))
  370.        stream)
  371.     (format stream " ~2D ~2D:~2,'0D:~2,'0D " date hour minute second)
  372.     (cond ((= time-zone 0)
  373.        (princ "GMT" stream))
  374.       (t (princ (nth (- time-zone 5)
  375.              '("E" "C" "M" "P"))
  376.             stream)
  377.          (princ (if daylight-savings-p "D" "S") stream)
  378.          (princ "T")))
  379.     (format stream " ~4D" year)))
  380.  
  381. ;;; CL provides no externalp function, and neither does
  382. ;;; MCL (although it keeps this info with the symbol).
  383. (defun externalp (symbol)
  384.   (multiple-value-bind (ignore type) 
  385.       (find-symbol (symbol-name symbol) (symbol-package symbol))
  386.     (eq type :external)))
  387.  
  388. ;;; Packages
  389.  
  390. ; +++ make this a setf method
  391. (defun add-nickname (package nickname)
  392.   (rename-package package
  393.                   (package-name package)
  394.                   (adjoin nickname (package-nicknames package) :test #'string-equal)))
  395.  
  396. ;;; Streams
  397.  
  398. (defun stream-copy (in out)
  399.   (do (char) (())
  400.     (setq char (read-char in nil :eof))
  401.     (if (eq char :eof)
  402.       (return)
  403.       (write-char char out))))
  404.  
  405. ;;; CLOS
  406.  
  407. (defclass plist-mixin () ((plist :initform nil)))
  408.  
  409. (defmethod oget ((o plist-mixin) property &optional (default nil))
  410.   (getf (slot-value o 'plist) property default))
  411.  
  412. (defmethod oput ((o plist-mixin) property value)
  413.   (setf (getf (slot-value o 'plist) property)
  414.         value))
  415.  
  416. (provide :mt-utils)
  417.